home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / zprint.t < prev    next >
Text File  |  1988-02-05  |  8KB  |  204 lines
  1. (herald zprint
  2.         (env tsys
  3.              (osys kernel)
  4.              (osys character)
  5.              (osys string)
  6.              (osys buffer)
  7.              (osys vm_port)))
  8.  
  9. ;;; Copyright (c) 1985 Yale University
  10. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  11. ;;; This material was developed by the T Project at the Yale University Computer 
  12. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  13. ;;; and to use it for any purpose is granted, subject to the following restric-
  14. ;;; tions and understandings.
  15. ;;; 1. Any copy made of this software must include this copyright notice in full.
  16. ;;; 2. Users of this software agree to make their best efforts (a) to return
  17. ;;;    to the T Project at Yale any improvements or extensions that they make,
  18. ;;;    so that these may be included in future releases; and (b) to inform
  19. ;;;    the T Project of noteworthy uses of this software.
  20. ;;; 3. All materials developed as a consequence of the use of this software
  21. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  22. ;;;    of acknowledging credit in academic research.
  23. ;;; 4. Yale has made no warrantee or representation that the operation of
  24. ;;;    this software will be error-free, and Yale is under no obligation to
  25. ;;;    provide any services, by way of maintenance, update, or otherwise.
  26. ;;; 5. In conjunction with products arising from the use of this material,
  27. ;;;    there shall be no use of the name of the Yale University nor of any
  28. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  29. ;;;    without prior written consent from Yale in each case.
  30. ;;;
  31.  
  32.  
  33. ;;; Z system printer
  34. ;;; Externel Entries: Z-PRINT, Z-WRITE, Z-FORMAT, Z-PROMPT
  35.  
  36. (lset *z-output-radix* 10)
  37.  
  38. (define-integrable (z-print form iob)  (z-write iob form))
  39.  
  40. (define (z-write iob form)
  41.   (xcond ((not (reasonable? form))
  42.           (z-write-random iob "Unreasonable" form))
  43.          ((string? form)
  44.           (vm-write-char iob #\")
  45.           (vm-write-string iob form)
  46.           (vm-write-char iob #\"))
  47.          ((fixnum? form)
  48.           (vm-write-fixnum iob form *z-output-radix*))
  49.          ((null? form) (vm-write-string iob "()"))
  50.          ((pair? form)
  51.           (z-write-pair iob form))
  52.          ((symbol? form)
  53.           (plain-write-symbol iob form))
  54.          ((extend? form)
  55.           (z-write-extend iob form))
  56.          ((true-header? form)
  57.           (vm-write-string iob "#T"))
  58.          ((char? form)
  59.           (cond ((char= form #\rubout) (vm-write-string iob "#\\rubout"))
  60.                 ((char= form #\space) (vm-write-string  iob "#\\space"))
  61.                 ((char< form #\space)
  62.                  (vm-write-string iob "#^")
  63.                  (vm-write-char iob (ascii->char (fx+ (char->ascii form)
  64.                                                      #o100))))
  65.                 ((char> form #\rubout)
  66.                  (vm-write-string iob "#{Char ")
  67.                  (vm-write-fixnum iob form *z-output-radix*)
  68.                  (vm-write-char iob #\}))
  69.                 (else (vm-write-string iob "#\\")
  70.                       (vm-write-char iob form))))
  71.          ((nonvalue? form)
  72.           (vm-write-string iob "{Has no value}"))))
  73.  
  74. (define (z-write-pair iob l)
  75.   (cond ((null? l) (vm-write-string iob "()"))
  76.         (else
  77.          (vm-write-char iob #\()
  78.          (iterate loop ((l l))
  79.            (z-write iob (car l))
  80.            (cond ((atom? (cdr l))
  81.                   (cond ((not (null? (cdr l)))
  82.                          (vm-write-space iob)
  83.                          (vm-write-char iob #\.)
  84.                          (vm-write-space iob)
  85.                          (z-write iob (cdr l))))
  86.                   (vm-write-char iob #\)))
  87.                  (else
  88.                   (vm-write-space iob)
  89.                   (loop (cdr l))))))))
  90.  
  91. (define (z-write-extend iob form)
  92.   (cond ((text?   form)
  93.          (vm-write-string iob "#{Text ")
  94.          (vm-write-text  iob form (text-length form))
  95.          (vm-write-string iob "}"))
  96.         ((vector? form) 
  97.          (z-write-object iob "Vector"  (vector-length form)))
  98.         ((vcell? form)
  99.          (z-write-object iob "Vcell"   (vcell-id form)))
  100.         ((foreign? form)
  101.          ;; write the low 30 bits!
  102.          (z-write-object iob "Foreign" (mref-integer form 0)))
  103.         (else
  104.          (z-write-random iob (cond ((closure?   form) "Closure")
  105.                                    ((template? form) "Template")
  106.                               ;++   ((float?    form) "Float")
  107.                                    ((bytev?    form) "Bytev")
  108.                                    ((unit?     form) "Unit")
  109.                                    (else             "Extend"))
  110.                           form))))
  111.  
  112.  
  113. (define (z-write-random iob type-string obj)
  114.   (z-write-object iob type-string (descriptor->fixnum obj)))
  115.  
  116. (define (z-write-object iob type-string id)
  117.   (vm-write-string iob "#{")
  118.   (vm-write-string iob type-string)
  119.   (vm-write-space iob)
  120.   (z-write iob id)
  121.   (vm-write-char iob #\} ))
  122.  
  123. ;;; Z-FORMAT
  124.  
  125. (define (z-format iob fmt . args)
  126.   (z-format-aux iob fmt args '#t))  ; always force output in z system
  127.  
  128. (define (z-prompt iob fmt . args)
  129.   (z-format-aux iob fmt args '#t))
  130.  
  131. (define (z-format-aux iob fmt args force?)
  132.   (let ((fmt (chopy (cond ((string? fmt) fmt)
  133.                           ((and (pair? fmt)
  134.                                 (string? (car fmt)))
  135.                            (car fmt))
  136.                           (else
  137.                            (error "losing z-format string!")))))
  138.         (iob (if (buffer? iob) 
  139.                  iob
  140.                  (error "losing z-format port - ~s" iob))))
  141.     (iterate loop ((args args))
  142.       (cond ((string-empty? fmt)
  143.              (if force? (vm-force-output iob))
  144.              (no-value))
  145.             ((char= (char fmt) #\~)
  146.              (string-tail! fmt)
  147.              (let ((op (char-upcase (string-head fmt))))
  148.                (string-tail! fmt)
  149.                (case op
  150.                  ((#\A) ((cond ((string? (car args)) vm-write-string)
  151.                                ((char? (car args))   vm-write-char)
  152.                                (else                 z-write))
  153.                          iob
  154.                          (car args))
  155.                         (loop (cdr args)))
  156.                  ((#\B) (vm-write-fixnum iob (car args) 2)
  157.                         (loop (cdr args)))
  158.                  ((#\C) (vm-write-char iob (car args))
  159.                         (loop (cdr args)))
  160.                  ((#\D) (vm-write-fixnum iob (car args) 10)
  161.                         (loop (cdr args)))
  162.                  ((#\O) (vm-write-fixnum iob (car args) 8)
  163.                         (loop (cdr args)))
  164.                  ((#\P) (if (fx> (car args) 1) (vm-write-char iob #\s))
  165.                         (loop (cdr args)))
  166.                  ((#\S) (z-write iob (car args))
  167.                         (loop (cdr args)))
  168.                  ((#\X) (vm-write-fixnum iob (car args) 16)
  169.                         (loop (cdr args)))
  170.                  ((#\%) (vm-newline iob)
  171.                         (loop args))
  172.                  ((#\&) (if (fx> (iob-h iob) 0) (vm-newline iob))
  173.                         (loop args))
  174.                  ((#\~) (vm-write-char iob #\~)
  175.                         (loop args))
  176.                  ((#\_) (vm-write-space iob)
  177.                         (loop args))
  178.                  ((#\T) (vm-write-space iob)
  179.                         (loop args))
  180.                  (else
  181.                   (cond ((digit? op 10)
  182.                          (z-skip-digits fmt)
  183.                          (loop args))
  184.                         ((whitespace? op)
  185.                          (z-skip-whitespace fmt)
  186.                          (loop args))
  187.                         (else
  188.                          (z-format iob "~~~c" op)))))))
  189.             (else
  190.              (vm-write-char iob (string-head fmt))
  191.              (string-tail! fmt)
  192.              (loop args))))))
  193.  
  194.  
  195. (define (z-skip-digits str)
  196.   (cond ((digit? (char str) 10)
  197.          (z-skip-digits (string-tail! str)))
  198.         (else str)))
  199.  
  200. (define (z-skip-whitespace str)
  201.   (cond ((whitespace? (char str))
  202.          (z-skip-whitespace (string-tail! str)))
  203.         (else str)))
  204.